Mac100% 1998 November

home *** CD-ROM | disk | FTP | other *** search

/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / pnuc1 < prev next >

Wrap

Text File | 1998-06-16 | 28KB | 1,086 lines

¥ Objects, constants, values etc. forward INTERPRET ¥ Not a vector any more - we never used that feature forward REFILL forward FREFILL forward THROW false value RAinMod ¥ Set if a relocatable address is in a module false value echo? ¥ Set if we're echoing during first stage load false value err_info_valid? variable #TIB variable >IN 0 value LATEST 0 value CURR-DEF 0 value FENCE 0 value SRC-START 0 value SRC-LEN 0 value SOURCE-ID 0 value ACTW 0 value OUT 0 value #lines_read 0 value STATE false value CSTATE 10 value BASE -1 value DPL 0 value HLD false value CASE_IN_NAMES? 0 value throwHandler big# value DotStkLim -1 value SLEEPTICKS 0 value PROCESSOR true constant AppleEvents? ¥ AppleEvents are always available on PPC true constant GestaltAvail? ¥ Likewise for Gestalt ¥ The following values are used internally by Mops. 0 value CD_gpr# 0 value TO_gpr# 0 value const_data_start 0 value CD_GPR_loc 0 value savedRP 0 value MMRgn 0 value meth_seg# ¥ 0 value seg#_accessed ¥ 0 value class_seg# $ BFF12345 , ¥ marker so we can easily recognize the ¥ execution buffer variable exBuff 512 allot ¥ the buffer $ 98765432 , ¥ marker so we can recognize the end 0 value exBuff_offs false value MRopen? false value initzed? 0 value quitapp? 0 value frNxtDP 0 value (err#) 0 value loc# 0 value #P 0 value #PL 0 value #FP 0 value #FPL 0 value tempObj_framesize ¥ if nonzero, this is the size of the extra ¥ part of the return stack frame, used for ¥ temp objects. 0 value releaseTemps_xt 0 value fltflg 0 value local? 0 value method? 0 value ^meth_link 0 value selfref? 0 value objclass 0 value #1st 0 value #last 0 value heldMod 0 value heldModStart ¥ 0 value heldModBase 0 value methindex false value sacomp? true value relocchk? false value inhibitmb? 0 value sups2skip false value savingdic? BL constant BL 8 constant #THREADS big# constant BIG# -300 constant FILE-MARK ¥ Some handler code values that we need to be able to access from ¥ above the nucleus: classCode constant CLASSCODE objcode constant OBJCODE FvalCode constant FVALCODE true value CURS? true value UCFLAG inlMk constant INLMK 0 value currBase 0 value colAflg ¥ 0 value tempPtr variable tempVbl 16 allot ¥ ============================== ¥ SYSTEM VECTORS ¥ ============================== (* ['] (emit) -> emitvec ['] (cr) -> crvec ['] (type) -> typevec ['] (spaces) -> spvec ['] (emit) -> echovec ['] (sf) -> setfWind ¥ 0 -> quitvec ¥ mh May94 - quit doesn't get changed any more ['] bye -> byevec *) ' null sVect HEADER : rtnFalse 0 ; ' null sVect LOGVEC ¥ ' rtnFalse sVect UFIND dynamicVect EXTRAFIND ¥ ' null sVect NUMACCUMULATE ' null sVect PAUSE ' null sVect ?PAUSE ' null sVect GETSPACE ' null sVect RNGERR ' null sVect $ERR ' null sVect ARITHERR ' null sVect EXTRA_INITS ' null sVect ERRORVEC ' null sVect QUITVEC ' null sVect ABORTVEC ' null sVect SETFWIND ¥ ' null sVect DIE ¥ ' null sVect DFLT-DIE ¥ ' null sVect FREFILL ' null sVect MODLOAD ¥ ' null sVect TEIDLE ' null sVect COMPINLINE ¥ ' null sVect INTERPRET ' null sVect OPENAPPVEC ' null sVect OPENDOCVEC ' null sVect PRINTDOCVEC ' null sVect QUITAPPVEC ' null sVect READ1DOCVEC ' null vect TEidle_vect ¥ ' null vect codeGen_vect ¥ ========= dummy words used for accessing locals (see zArgs) ========= $ BC0D dummy_op LOCPARM $ BC25 dummy_op FLOCPARM ¥ ======== Dictionary header address conversion ======== : ?DP ; ¥ TRAVERSE converts an addr pointing to one end of the name field ¥ to one pointing to the other. : TRAVERSE { addr dirn ¥ cnt -- addr' } 32 -> cnt dirn 0>= IF ¥ going up addr c@ $ 1F and 4+ -4 and 1- ++> addr ELSE ¥ going down BEGIN 1 --> addr addr c@x 0< IF addr EXIT drop THEN 1 --> cnt cnt NUNTIL THEN addr ; : N>LINK 4- ; : L>NAME 4+ ; : NAME> 1 traverse 3+ ; : LINK> L>name name> ; ¥ >BODY ( xt -- dfa ) has to go to the data area for variables, values ¥ etc. This isn't (and can't ever be) standard, since these kinds of ¥ words don't have an 'xt' under the standard. But in Mops, you can ¥ tick them, and use >BODY on the result to get to the data. : >BODY 2+ @abs ; : >NAME 3- -1 traverse ; : >LINK >name n>link ; : >HDLR 2- ; ¥ ============================== ¥ STACK MANIPULATION ¥ ============================== $ BD0F $ 6200 special_op DUP $ BD0F $ 6300 special_op 2DUP $ BD0F $ 6400 special_op DROP $ BD0F $ 6500 special_op 2DROP $ BD0F $ 6600 special_op SWAP $ BD0F $ 6700 special_op OVER $ BD0F $ 6800 special_op NIP $ BD0F $ 6900 special_op TUCK $ BD0F $ 6A00 special_op ROT $ BD0F $ 6B00 special_op DOWN $ BD0F $ 6B00 special_op -ROT ¥ these are synonyms $ BD0F $ 6C00 special_op 2SWAP ¥ FP stack ops: $ BD0F $ 7200 special_op FDUP $ BD0F $ 7300 special_op F2DUP $ BD0F $ 7400 special_op FDROP $ BD0F $ 7500 special_op F2DROP $ BD0F $ 7600 special_op FSWAP $ BD0F $ 7700 special_op FOVER $ BD0F $ 7800 special_op FNIP $ BD0F $ 7900 special_op FTUCK $ BD0F $ 7A00 special_op FROT $ BD0F $ 7B00 special_op FDOWN $ BD0F $ 7C00 special_op F2SWAP ¥ I use the following in inline code sequences here in the nucleus, before ¥ locals are avaliable. And they're also handy in inlines. $ BD0F $ 6D00 special_op 2PICK $ BD0F $ 6E00 special_op 3PICK $ BD0F $ 6F00 special_op 3ROLL :ppc_code PICK r4 0 cmpi, ¥ is it 0 pick? eq if, r4 r3 r3 or, ¥ yes - copy TOS else, r5 r4 2 0 29 rlwinm, ¥ no - mult index by 4 r5 r5 -4 addi, ¥ and subtract 4 to get SP offset r4 r18 r5 lwzx, ¥ grab the cell then, blr, ¥ and return. ;ppc_code ¥ ============================= ¥ SIMPLE ARITHMETIC ¥ ============================= $ BD06 otAdd special_op + $ BD06 otSub special_op - $ BD06 otMul special_op * $ BD06 otMul special_op *W ¥ don't need this as a separate op on PPC $ BD06 otMulh special_op *HI ¥ will normally only be used internally $ BD06 otUMulh special_op *UHI ¥ ditto $ BD06 otDiv special_op / $ BD06 otUDiv special_op U/ : M* ( n1 n2 -- d ) inline{ 2dup * down *hi} ; : UM* ( u1 u2 -- ud ) inline{ 2dup * down *uhi} ; ¥ we need um* - the standard sez so!! ¥ Special arith ops to get us specific instructions, mainly for use ¥ in inline sequences. We leave it as an exercise for the reader ¥ to work out what the instructions are. $ BD06 otAddc special_op __addc $ BD06 otAdde special_op __adde $ BD06 otAddze special_op __addze $ BD06 otSubfc special_op __subfc $ BD06 otSubfe special_op __subfe $ BD06 otSubfze special_op __subfze ¥ NEGATE and DNEGATE. The latter can be done with the special ops we just ¥ defined. $ BD06 otNEG special_op NEGATE : DNEGATE inline{ swap 0 __subfc swap __subfze} ; ¥ We need D+ in number input, so we might as well put D- here as well. ¥ These sequences do the job in 2 or 3 instructions. : D+ ( d1 d2 -- d3 ) inline{ swap 3roll __addc down __adde} ; : D- ( d1 d2 -- d3 ) inline{ swap 3roll swap __subfc down __subfe} ; ¥ FP: $ BD06 otFADD special_op F+ $ BD06 otFSUB special_op F- $ BD06 otFMUL special_op F* $ BD06 otFDIV special_op F/ $ BD06 $ 54 special_op FABS $ BD06 $ 55 special_op FNEGATE ¥ Shifts: $ BD30 $ 2A00 special_op << $ BD30 $ 2A00 special_op LSHIFT $ BD30 $ 2A01 special_op >> $ BD30 $ 2A01 special_op RSHIFT $ BD30 $ 2A03 special_op A>> ¥ the following inline definitions use some ops like > which we haven't ¥ defined in the nucleus image yet. But since inlines use EVALUATE, ¥ as long as the ops are defined somewhere in the nucleus there should ¥ be no problem, since we precompile the nucleus. : 2* inline{ dup +} ; : 4* inline{ 2 <<} ; : 2/ inline{ 1 a>>} ; : 4/ inline{ 2 a>>} ; : UNDER+ ¥ ( a b c -- a+c b ) inline{ rot + swap} ; : MAX inline{ 2dup >= dup not rot and down and or} ; : MIN inline{ 2dup < dup not rot and down and or} ; ¥ we use >= instead of > for MAX, since this gives one ¥ less instruction in the case 0 MAX. But for MIN, ¥ using < gives TWO less instructions than <= (just 2) : UMAX inline{ 2dup u> dup not rot and down and or} ; : UMIN inline{ 2dup u< dup not rot and down and or} ; ¥ Here u>/u< gives one less instruction than ¥ u>=/u<=. : ABS inline{ dup 31 a>> tuck + xor} ; ¥ yep, it works!! ¥ +- ( n1 n2 -- n3 ) negates n1 if n2 is negative. I like this name ¥ better than ?negate, since n2 isn't a flag. Note that ABS is ¥ equivalent to DUP +-. : +- inline{ 31 a>> tuck + xor} ; : #ALIGN4 inline{ 3+ -4 and} ; ¥ other alignment words are in pnuc3, ¥ but we need this one earlier. : EXTEND inline{ 16 << 16 a>>} ; : S>D inline{ dup 31 a>>} ; ¥ ============================= ¥ LOGICAL OPERATIONS ¥ ============================= ¥ NOT and INVERT are synonyms. $ BD06 otNOT special_op NOT $ BD06 otNOT special_op INVERT $ BD06 otAND special_op AND $ BD06 otOR special_op OR $ BD06 otXOR special_op XOR ¥ Logical operations directly on a memory byte. We define these as inlines, ¥ since the'll only generate a few instructions. : CSET ¥ ( c addr -- ) ORs c into the byte at addr. inline{ dup c@ rot or swap c!} ; : CRESET ¥ ( c addr -- ) clears bits in byte at addr, corresponding ¥ to the bits SET in c. inline{ dup c@ rot not and swap c!} ; : CTOGGLE ¥ ( c addr -- ) Exclusive-ORs c into the byte at addr. inline{ dup c@ rot xor swap c!} ; : CREPLACE ¥ ( c mask addr -- ) ¥ Replaces bits in the addressed byte with the corresponding ¥ bits from c, in those positions where the mask has ones. inline{ 2dup c@ swap not and 2swap and or swap c!} ; (* : CREPLACE { c mask addr -- } addr c@ mask not and c mask and or addr c! ; *) ¥ Logical operations on a memory bit - now omitted. Almost unused. ¥ =========================== ¥ COMPARISONS ¥ =========================== $ BD10 $ 2607 special_op = $ BD10 $ 2606 special_op <> $ BD10 $ 260C special_op >= $ BD10 $ 260D special_op < $ BD10 $ 260F special_op <= $ BD10 $ 260E special_op > $ BD10 $ 2605 special_op U< $ BD10 $ 2603 special_op U<= $ BD10 $ 2602 special_op U> $ BD10 $ 2604 special_op U>= $ BD10 $ 2617 special_op 0= $ BD10 $ 2616 special_op 0<> $ BD10 $ 261C special_op 0>= $ BD10 $ 261D special_op 0< $ BD10 $ 261F special_op 0<= $ BD10 $ 261E special_op 0> $ BD2A cmpEQ special_op F= $ BD2A cmpNE special_op F<> $ BD2A cmpGE special_op F>= $ BD2A cmpLT special_op F< $ BD2A cmpLE special_op F<= $ BD2A cmpGT special_op F> ¥ FP: $ BD2A cmpZEQ special_op F0= $ BD2A cmpZNE special_op F0<> $ BD2A cmpZGE special_op F0>= $ BD2A cmpZLT special_op F0< $ BD2A cmpZLE special_op F0<= $ BD2A cmpZGT special_op F0> : WITHIN? ¥ ( n lo hi -- n b ) Returns true if lo <= n <= hi. ¥ We define it inline which involves a lot of stack juggling, ¥ but all that gets taken out at compile time, so the compiled ¥ code is actually optimum. inline{ rot tuck >= down tuck <= rot and} ; (* that surely needs an explanation: rot ( lo hi n ) tuck ( lo n hi n ) >= down ( b lo n ) tuck ( b n lo n ) <= ( b n b' ) rot and *) : UWITHIN? ¥ ( u lo hi -- u b ) An unsigned version of WITHIN? inline{ rot tuck u>= down tuck u<= rot and} ; ¥ =========================== ¥ FETCHES AND STORES ¥ =========================== $ 6102 0 fetch_op @ $ 6102 0 fetch_op >PTR ¥ In our system, this is an alias for @. $ 6101 0 fetch_op W@ $ 6101 1 fetch_op W@X $ 6100 0 fetch_op C@ $ 6100 1 fetch_op C@X $ BD32 simple_op F@ $ BD33 simple_op F! $ BD42 simple_op SF@ $ BD43 simple_op SF! $ BD08 $ 6002 special_op ! $ BD08 $ 2102 special_op +! $ BD08 $ 2202 special_op -! $ BD08 $ 6001 special_op W! $ BD08 $ 2101 special_op W+! $ BD08 $ 2201 special_op W-! $ BD08 $ 6000 special_op C! ¥ ============================================ ¥ DO LOOPS and RETURN STACK OPERATIONS ¥ ============================================ (* Note: >R, R> and R@ are defined already (at the start of Setup, since I needed >R so it was logical to put them all there). We keep the loop index I in a reg, but the return stack is entirely in memory, except that in leaf words we don't save/restore the link register. This means that I can be used in words called from within DO loops. In fact I can be used as another local variable. But this is non-standard, so not a good idea. But it's useful for testing. During DO loops, the info for any containing DO loop is saved on the return stack in the order I (on top), limit, count register. Thus J is at offset zero off r17 (rtn stk ptr), and K is at offset 12. *) I_reg gpr I : J inline{ [ 17 0 (litaddr) ] @} ; ¥ r17 is return stk pointer : K inline{ [ 17 8 (litaddr) ] @} ; ¥ ========================= ¥ OBJECT ADDRESSING ¥ ========================= (* ^BASE and SELF give the base address of the current object. There are two words because "base address of the current object" can have two meanings, thanks to multiple inheritance. ^BASE give what we might call the local base - the base address of the current object considered as an object of the class in which the ^BASE appears or from which it is called. In other words, this is the address of the first ivar of the class in which the current method is declared. Note that all ivars of this class will be at fixed offsets from ^BASE. However with multiple inheritance, these ivars might be preceded by ivars of a different (inherited) class. SELF simply the base address of the current (dynamic) object, that is, the address of the first ivar (regardless of which class it's inherited from). SELF and ^BASE might give identical results, but if they differ, SELF must be lower. Compiled code in methods needs to access ivars using ^BASE, since the offsets are fixed. The offset from SELF of a given ivar might be different in different objects. For this reason we keep ^BASE in a machine register, but compute SELF. *) ¥ obj_base_reg reg ^BASE : SELF ( -- addr ) ¥ Returns the "real" base addr of the current object. (^base) 4- dup w@x + ¥ ^class addr 8 + ; ¥ forward to beginning of obj data ¥ ========================= ¥ SEGMENT HANDLING ¥ ========================= (* A segment table (ST) entry is 8 bytes long: byte 0 flags bytes 1-3 length of segment bytes 4-7 base addr A free segment is marked by bytes 0-3 being all zero. Currently we don't have such a thing as a zero-length segment, though if this ever became useful we could define a flag bit to mean a segment isn't free, so that bytes 0-3 being all zero would still mean the seg is free. Note that 2^^24 is more than adequate for a maximum length, so there's no problem with using the hi byte for flags. The maximum number of available ST slots is max_segs. We number segments from 8 up, corresponding to the hi byte of relocatable addresses. Thus the highest legal seg# is max_segs + 7. (Offsetting the seg# in this way makes handling reloc addrs slightly easier, and also means that zero is illegal as a reloc addr - probably a good idea.) *) : get_free_seg_pair { ¥ ^entry -- ^entry n } max_segs 2 DO i 8 * segTable + -> ^entry ^entry @ ^entry 8 + @ or NIF ¥ found the first free even-odd pair 1 ^entry ! ¥ give them a dummy length of 1 so we can see 1 ^entry 8 + ! ¥ they're not free ^entry i 8 + UNLOOP EXIT THEN 2 +LOOP 208 die ¥ table full! Help!! ; : segTable_entry ¥ ( seg# -- ^entry ) 8 - 0 max_segs within? NIF 207 die THEN 8 * segTable + ; : make_seg_absent ¥ ( seg# -- ) segTable_entry 4+ nilP swap ! ¥ nilP means it's absent. Note we leave the ¥ length alone, since the seg is still assigned ¥ to somebody. ; : free_seg ¥ ( seg# -- ) segTable_entry 0 over ! nilP swap 4+ ! ; 0 value cctest : dotest true -> cctest ; : addr>S&D { addr ¥ ^entry BA len -- seg# displ } ¥ compMod $ 10000000 u> if dbgr then ¥ addr $ 1000 u< if dbgr then compMod 0<> comp_seg# and IF comp_seg# 8 - 8 * segTable + -> ^entry ^entry @ $ 00ffffff and -> len ^entry 4+ @ -> BA addr modcode_comp_start BA len + uwithin? IF ¥ found! modcode_comp_start - comp_seg# swap EXIT THEN ^entry 8 + @ $ 00ffffff and -> len ^entry 12 + @ -> BA ( addr ) moddata_comp_start BA len + uwithin? IF moddata_comp_start - comp_seg# 1+ swap EXIT THEN drop THEN max_segs 0 DO i 8 * segTable + -> ^entry ^entry @ $ 00ffffff and -> len len IF ¥ something there ^entry 4+ @ -> BA BA nilP <> IF ¥ seg is present addr BA dup len + uwithin? IF ¥ found! addr is within this segment BA - i 8 + swap UNLOOP EXIT ELSE drop THEN THEN THEN LOOP 0 0 ¥ search failed - return two zeros ; ¥ ============================= ¥ MISCELLANEOUS LOW-LEVEL WORDS ¥ ============================= ¥ SP@ should really only be used for stack dumping. Therefore the ¥ main job is to ensure the memory part of the stack is updated to ¥ what's in the regs. :ppc_code SP@ $ 0100 codeHere 2- w! ¥ change flags to specify 1 result in regs. This ¥ simplifies things, since this 1 result is just ¥ the updated data stack pointer. r3 -4 rSP stw, r4 -8 rSP stwu, r3 rSP mr, blr, ;ppc_code : SP! -> SP ; RP_reg gpr RP@ ¥ synonym for RP in Mops : RP! 0 -> exBuff_offs -1 -> (^base) -> RP ; : FSP! -> FSP ; : BOUNDS inline{ over + swap} ; : HERE inline{ dp} ; : ALLOT inline{ ++> dp} ; : ROOM ( -- n ) code_limit CDP - ; : ROOM2 ( -- code-room data-room ) code_limit CDP - data_limit DP - ; : HEADROOM ( -- n ) ¥ On the 68k, returns the distance from DP to the top of ¥ the A4 addressing range. Here on the PPC we make it ¥ the distance from CDP to the top of the mainCode addressing ¥ range - that's probably somewhat useful, though the ¥ distance from DP to the top of the mainData addressing ¥ range would be useful as well. mainCode half_displ_range + CDP - ; : UNUSED inline{ room} ; : COUNT inline{ dup 1+ swap c@} ; : LENGTH inline{ dup 2+ swap w@} ; : DEPTH SP0 SP - 4/ 2+ ; ¥ we have 2 cells in regs on entry : FDEPTH FSP0 FSP - 3 a>> 2+ ; ¥ ditto : DIGIT { char #base -- b } false char & z u> ?EXIT ¥ if above LC letters, fail char & a u>= IF $ DF and> char THEN ¥ LC letter -> UC $ 30 --> char ¥ '0'-'9' -> 0-9 char 0< ?EXIT ¥ if not a digit, fail char 10 >= IF 7 --> char ¥ A-Z -> 10-35 char 10 < ?EXIT ¥ but if not a letter, fail THEN char #base >= ?EXIT ¥ if char now > base, fail drop char true ¥ if we got here, success! ; : DECIMAL 10 -> base ; : HEX 16 -> base ; (* HASH produces a 32-bit hash value. We always set the top bit (so that a hashed value is never zero, and is always distinguishable from a relocatable address, which is always "positive"). This means that we effectively have 2**31 hash possibilities. This is large enough that hash collisions should hardly ever occur. If a 16-bit hash value is required, as in Neon, use wHash. We use assembly for the inner loop, mainly because we don't yet have a good way of specifying a rotate in high-level. But it's interesting that I hardly ever have to resort to assembly for anything any more... *) :ppc_code (hash) ¥ ( addr -- hash ) r5 $ 12345678 lli, r5 8 srwi, r0 0 r4 lbz, r0 $ 7F andi., r0 mtctr, rX r4 1 addi, r4 r0 0 addi, begin, r4 r4 7 0 31 rlwinm, r0 0 rX lbz, rX 1 addi, r4 r0 xor, dnz until, blr, ;ppc_code : HASH (hash) dup 0> IF not THEN ; : WHASH (hash) dup $ FFFF and swap 16 >> xor ; : <^ELEM> { index ¥ addr -- addr index } ¥ Returns addr of indexed element in current object. ¥ (^base) dup 4- w@x + ¥ ^class addr ¥ dup 6 + w@x + -> addr ¥ indexed base addr ¥ index addr 4- @ u> ?trap ¥ trap if out of range - note we store ¥ limit-1 in the object, so equal is OK. (^base) 2- dup w@x + -> addr ¥ indexed area base addr index addr 4- @ u> ?trap ¥ trap if out of range - note we store ¥ limit-1 in the object, so equal is OK. addr index ; : (^ELEM) <^elem> over 6 - w@ * + ; ¥ compiled by ^ELEM if we're not ¥ expanding an inline defn - see ¥ qClass. : ^ELEM1 <^elem> + ; : ^ELEM2 <^elem> dup + + ; : ^ELEM4 <^elem> 4* + ; : IDXBASE { ¥ addr -- addr } ¥ Returns start addr of indexed area in current object. ¥ (^base) dup 4- w@x + ¥ ^class addr ¥ dup 2- w@x + -> addr ¥ indexed base addr (^base) 2- dup w@x + -> addr ¥ indexed area base addr addr 4- @ 0< ?trap ¥ trap if not indexed addr ; : LIMIT idxbase 4- @ 1+ ; ¥ we store limit-1 in the object (* Extra multiplication and division words. On the 68k, we dispensed with all double length (64-bit) arithmetic in the nucleus, since the hardware didn't provide it. We used a kludged version of I/O words such as #, in which we just ignored the high word. We required loading of an extra file (longMath) if the real 64-bit words were needed. However here we do provide a few 64-bit words since 32*32->64 is easy, and the Compiler Writers' Guide has given us a 64/64->64 division routine. This means that we don't have to kludge # et al, and don't need a PowerPC version of longMath. *) : /MOD inline{ 2dup / -> rX rX * - rX} ; ¥ tried assembly, but the code compiled by this was ¥ identical, except for reg numbers :-) : U/MOD inline{ 2dup u/ -> rX rX * - rX} ; : MOD inline{ /mod drop} ; (* 64-bit division on 32-bit PowerPC implementations isn't easy, since they took away the MQ register, and left us with only 32/32->32 instructions. But fortunately the Compiler Writer's Guide tells us how to do 64/64->64, so here we go... *) :ppc_code UD/MOD ( ud_dvd ud_dsr -- ud_rem ud_quot ) (* On entry: divisor = r4:r3, dividend in 0(rSP):4(rSP), and we move it to r6:r5. We use tmp = r8:r7. r0 and r10 are scratch. Note the dividend is only 64 bits, instead of the 128 that would normally go with a 64 bit divisor. We assume the high 64 bits are zero. This means that no divisor/dividend combinations can overflow, unless the divisor is zero. Note also we put the most significant cell second in the registers, because that's the way the regs get passed in to us and the way we need to return them, and it's less confusing to be consistent all the way through - once we get over the confusion of having the registers this way around. *) ¥ first we check for zero divisor r0 r3 r4 or., ne if, r6 0 rSP lwz, ¥ get dividend to r6:r5 r5 4 rSP lwz, ¥ first we count the leading zeros in the dividend -> r0 r6 0 cmpi, ¥ dvd(hi) = 0? r0 r6 cntlzw, ¥ r0 = LZ in dvd(hi) r9 r5 cntlzw, ¥ r9 = LZ in dvd(lo) eq if, ¥ if dvd(hi) = 0 r0 r9 32 addi, ¥ LZ = LZ(lo) + 32 then, ¥ now we count the leading zeros in the divisor -> r9 r4 0 cmpi, ¥ dsr(hi) = 0? r9 r4 cntlzw, ¥ r9 = LZ in dsr(hi) r10 r3 cntlzw, ¥ r10 = LZ in dsr(lo) eq if, ¥ if dsr(hi) = 0 r9 r10 32 addi, ¥ LZ = LZ(lo) + 32 then, ¥ now we work out the shift amounts to minimize the number of ¥ iterations. r0 r9 cmp, ¥ compare dvd LZ to dsr LZ r10 r0 64 subfic, ¥ r10 = dividend sig digits (SD) le if, ¥ if divisor > dividend we keep going, ¥ otherwise we set quotient to 0 r9 r9 1 addi, r9 r9 64 subfic, ¥ r9 = divisor SD r0 r0 r9 add, ¥ r0 = dvd LZ + dsr SD, i.e. left shift ¥ of dvd for initial tmp r9 r9 r10 subf, ¥ r9 = dvd SD - dsr SD i.e. right shift ¥ of dividend for initial temp r9 mtctr, ¥ ..which is also the number of iterations. ¥ now we set up r8:r7:r6:r5 as the classic division register whose length ¥ is the sum of the quotient and remainder lengths - in our case, 128 bits. ¥ First, the hi-order part (r8:r7) is the dividend, right shifted by r9 ¥ (the number of iterations). r9 32 cmpi, ¥ r9 ? 32 r8 r9 -32 addi, ge if, ¥ r9 >= 32: r7 r6 r8 srw, ¥ lo word = dvd(hi) >> (r9-32) r8 0 li, ¥ hi word = 0 else, ¥ r9 < 32: r7 r5 r9 srw, ¥ lo word = dvd(lo) >> r9 r8 r9 32 subfic, r8 r6 r8 slw, ¥ r8 = dvd(hi) << (32-r9) r7 r7 r8 or, ¥ OR that into lo word r8 r6 r9 srw, ¥ hi word = dvd(hi) >> r9 then, ¥ Now the lo-order part of the division register (r6:r5) is the ¥ dividend left shifted by r0. r0 32 cmpi, ¥ r0 ? 32 r9 r0 -32 addic, ge if, ¥ r0 >= 32: r6 r5 r9 slw, ¥ hi word = dvd(lo) << (r0-32) r5 0 li, ¥ lo word = 0 else, ¥ r0 < 32: r6 r6 r0 slw, ¥ hi word = dvd(hi) << r0 r9 r0 32 subfic, r9 r5 r9 srw, ¥ r9 = dvd(lo) >> (r0-32) r6 r6 r9 or, ¥ OR that into hi word r5 r5 r0 slw, ¥ lo word = dvd(lo) << r0 then, ¥ Now for the main restoring division shift and subtract loop. ¥ With each shift we subtract the divisor from the top half of ¥ the 128-bit "register", but only use the result if it's positive. ¥ In this case we shift in a 1 into the low bit position. Otherwise ¥ we shift in a 0. This will be the next bit of the quotient. ¥ At the end of the loop, we'll have the remainder in the high ¥ half, and the quotient in the low half. r10 -1 li, ¥ r10 = -1 for carry setting r8 r8 0 addic, ¥ clear carry initially CDPx ¥ loop start r5 r5 r5 adde, ¥ here we shift the long register r6 r6 r6 adde, ¥ left one place by adding each r7 r7 r7 adde, ¥ portion to itself, with carry r8 r8 r8 adde, r0 r3 r7 subfc, ¥ Subtract divisor from hi half r9 r4 r8 subfe., ¥ of long register -> r9:r0 ge if, ¥ Result was positive, so we use it r7 r0 mr, ¥ move result to hi half of long reg r8 r9 mr, r0 r10 1 addic, ¥ and set carry bit - then, ¥ carry bit will come into the lo ¥ bit position of the long reg on ¥ the next shift. dnz bc, ¥ loop ¥ now we write the results. The quotient is in the lo half of the long ¥ reg, but needs one more shift, bringing the carry into the lo bit. ¥ At the same time we get the quotient to r4:r3, where we want it. r3 r5 r5 adde, r4 r6 r6 adde, ¥ The remainder is in r8:r7 - we now put it back into the memory part ¥ of the stack, where the original dividend came from. As we always ¥ return 2 cells in registers from a code definition, we'll now ¥ have the remainder under the quotient, as required. r7 4 rSP stw, r8 0 rSP stw, blr, then, ¥ if we got here, the divisor > dividend, so the quotient is zero ¥ and remainder = dividend. The remainder is already in the right ¥ place so we only have to clear the quotient (r4:r3). r3 0 li, r4 0 li, blr, then, ¥ and if we got here, the divisor was zero. We THROW the code -10, which ¥ means "division by zero". r4 -10 li, r0 ' throw 2+ dicaddr, r0 mtctr, bctr, ;ppc_code : UM/MOD ( d u -- urem uquot ) 0 ud/mod drop nip ; : UMD/MOD ( ud_dvd u_dsr -- u_rem ud_quot ) 0 ud/mod rot drop ; : M/MOD ( d n ) { ¥ dvdSgn dsrSgn -- rem quot } false -> dvdSgn s>d dup -> dsrSgn tuck + xor over 0< IF down dnegate rot true -> dvdSgn THEN um/mod ¥ now we set the sign of the quotient - negative if the ¥ signs of the dividend and divisor differed. dvdSgn dsrSgn xor tuck + xor ¥ now we set the sign of the remainder - same as dividend. swap dvdSgn tuck + xor swap ; : */MOD inline{ -> rY m* rY m/mod} ; : */ inline{ */mod nip} ;